home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / BBS_UTL / BBS_PAS / MODEM.PAS < prev    next >
Pascal/Delphi Source File  |  1986-03-28  |  17KB  |  513 lines
  1. {$C-} {no user interrupts}
  2. {$U-}
  3. {$K-} {no stack checking - program works}
  4. program Modem;
  5.  
  6. { Written by Jack M. Wierda  Chicago Illinois
  7.   Modified by Steve Freeman
  8.  
  9.       LANGUAGE: TURBO Pascal
  10.       This program is in the public domain.
  11.  
  12.       This program is basically a re-write in PASCAL of Ward Christensen's
  13. Modem Program which was distributed in CP/M User's Group Volume 25. Identical
  14. and compatible options are provided to allow this program to work directly
  15. with XMODEM running under CP/M. }
  16.  
  17. const
  18.       Version = '12-Nov-84';
  19.       FredsPhone = '7-5038';
  20.       SignOnLine = 'ACGM10,RLIP,PSSWD';
  21.       MaxPhoneNums = 26;
  22.       COMport = 1;
  23.  
  24.       NUL   =   00;   SOH   = #$01;   EOT   = #$04;   ACK   = #$06;
  25.       TAB   =   09;   LF    = #$0A;   CR    = #$0D;   NAK   = #$15;
  26.       Space = ' ';    DELete = $7F;
  27.  
  28.       lastbyte = 127;
  29.       timeout  = 256;
  30.       errormax = 5;
  31.       retrymax = 5;
  32.       loopspersec = 6500;
  33.       Intseg: integer = 0; {filled with interrupt segment address}
  34.  
  35. type maxstr = string[255];
  36.      PhoneEntry = string[32];
  37.      PhoneStr = string[20];
  38.      BytePointer = ^byte;
  39.  
  40. var  COMbase: integer; {this will point to the Communications base}
  41.      WorkFile: file;
  42.      PhoneFile: text;
  43.      PhoneList: array[1..MaxPhoneNums] of PhoneEntry;
  44.      option, hangup, return, mode, baudrate : char;
  45.      sector : array[0..lastbyte] of byte;
  46.      base, N_Phones: integer;
  47.  
  48.      { interrupt vectors and pointers to them }
  49.      newvec, oldvec: BytePointer;
  50.      INT3: BytePointer absolute $0000:$002C; {for COM2:}
  51.      INT4: BytePointer absolute $0000:$0030; {for COM1:}
  52.      rcvbuf: array[0..127] of byte;
  53.      inptr, outptr: integer;
  54.      datardy: boolean;
  55. {.pa}
  56.   type hexstr = string[4];
  57.   function hex(num: integer): hexstr;
  58.     var i, j: integer;
  59.         h: string[16];
  60.         str: hexstr;
  61.     begin
  62.       str := '0000';   h := '0123456789ABCDEF';   j := num;
  63.       for i:=4 downto 1
  64.         do begin
  65.              str[i] := h[(j and 15)+1];
  66.              j := j shr 4;
  67.            end;
  68.       hex := str;
  69.     end;
  70. {.cp10}
  71.   function GetYN: char;
  72.     var c: char;
  73.     begin
  74.       repeat
  75.           read(kbd,c);
  76.           c := upcase(c);
  77.         until c in ['Y','N'];
  78.       writeln(c);
  79.       GetYN := c
  80.     end;
  81. {.cp4}
  82.   procedure SetDTR;
  83.     begin
  84.       port[base+4] := $09; {DTR on and INT enabled}
  85.     end;
  86. {.cp4}
  87.   procedure HangUpPhone; {hang up by terminating the line}
  88.     begin
  89.       port[base+4] := 0;
  90.     end;
  91. {.cp7}
  92.   function status: integer;
  93.     var st: integer;
  94.     begin
  95.       st := port[base+5];
  96.       st := st shl 8 + port[base+6];
  97.       status := st;
  98.     end;
  99. {.cp6}
  100.   procedure send(ch: char);
  101.     var s: byte;
  102.     begin
  103.       repeat s := port[base+5] and $20 until (s=$20);
  104.       port[base] := ord(ch);
  105.     end;
  106. {.cp6}
  107.   function get_rcv_char: char;
  108.     begin
  109.       get_rcv_char := chr(rcvbuf[outptr]);
  110.       outptr := (outptr + 1) and $7F;
  111.       if inptr=outptr then datardy := false;
  112.     end;
  113. {.cp5}
  114.   function receive: char;
  115.     begin
  116.       repeat until datardy;
  117.       receive := get_rcv_char;
  118.     end;
  119. {.cp9}
  120.   function ReadLine(seconds:integer): integer;
  121.     var j : integer;
  122.     begin
  123.       j := loopspersec * seconds;
  124.       repeat  j := j-1  until datardy or (j = 0);
  125.       if j = 0
  126.         then readline := timeout
  127.         else readline := ord(get_rcv_char);
  128.     end;
  129. {.cp8}
  130.   procedure PurgeLine;   {purge the receive register}
  131.     var c: char;
  132.     begin
  133.       repeat
  134.           if datardy then c := get_rcv_char;
  135.           delay(35);   { 300 baud time period for received char }
  136.         until not(datardy)
  137.     end;
  138. {.cp42}
  139.   procedure Set_RS232_Vector;
  140.  
  141.     procedure Int_Handler;
  142.     { This routine buffers all incoming received data }
  143.       begin
  144.         inline($50/$52/$57/$1E/                     {save registers}
  145.         $2E/             {CS:}
  146.         $8E/$1E/Intseg/  {MOV   DS,[Intseg]}        {get data segment pointer}
  147.         $BA/$FD/$03/     {MOV   DX,$3FD}            {is character ready?}
  148.         $EC/             {IN    AL,DX}
  149.         $24/$01/         {AND   AL,01}
  150.         $74/$19/         {JZ    here}               { no, skip entry}
  151.         $BA/$F8/$03/     {MOV   DX,$3F8}            { yes, get pointer}
  152.         $A1/inptr/       {MOV   AX,[inptr]}         {get index to buffer}
  153.         $97/             {XCHG  DI,AX}
  154.         $EC/             {IN    AL,DX}              {get data from receiver}
  155.         $88/$85/rcvbuf/  {MOV   [DI+rcvbuf],AL}     {put data into buffer}
  156.         $97/             {XCHG  DI,AX}              {increment pointer}
  157.         $40/             {INC   AX}
  158.         $24/$7F/         {AND   AL,$7F}
  159.         $A3/inptr/       {MOV   [inptr],AX}
  160.         $B8/$01/$00/     {MOV   AX,1}               {show data is ready}
  161.         $A2/datardy/     {MOV   [datardy],AX}
  162.                    {here}
  163.         $B0/$64/         {MOV   AL,64}              {EOI, level 4 on 8259}
  164.         $E6/$20/         {OUT   20,AL}
  165.         $1F/$5F/$5A/$58/$CF);                       {restore and return}
  166.       end;
  167.  
  168.     begin
  169.       Intseg := Dseg;
  170.       COMbase := $0400 + 2 * (COMport - 1);
  171.       oldvec := INT4;
  172.       newvec := ptr(cseg,ofs(Int_Handler)+7+5);
  173.       INT4 := newvec;
  174.       inline($BA/$3F8/         {MOV  DX,BASE}
  175.              $EC/$EC/$EC/$EC/  {IN   AL,DX}
  176.              $BA/$3FD/$EC/     {MOV  DX,BASE+5 ! IN  AL,DX}
  177.              $BA/$3FE/$EC);    {MOV  DX,BASE+6 ! IN  AL,DX}
  178.       datardy := false;   inptr := 0;   outptr := inptr;
  179.       inline($E4/$21/$24/$EF/$E6/$21); {turn off IRQ mask bit - enabled}
  180.     end;
  181. {.cp16}
  182.   procedure Setup(md, brc: char);
  183.     var al: integer;
  184.     begin
  185.       base := memw[0:COMbase];
  186.       port[base+3] := $83;         {access baud rate divisor and sets
  187.                                     8 data, no parity, 1 stop}
  188.       if md='O' then mode:=' ' else mode:='R';
  189.       baudrate := brc;
  190.       if baudrate='1'
  191.         then portw[base] := $0060     {1200 baud}
  192.         else portw[base] := $0180;    { 300 baud}
  193.       port[base+3] := $03;         {set access for xmt/rcv}
  194.       port[base+1] := $01;         {enable receiver interrupts}
  195.       SetDTR;                      {put station on-line}
  196.       return := 'N';
  197.     end;
  198. {.cp16}
  199.   procedure Initialize;
  200.     var mode, baudrate: char;
  201.     begin
  202.       repeat
  203.           write('Mode : A(nswer), O(riginate) ? ');
  204.           read(kbd,mode);   mode := upcase(mode);
  205.         until mode in ['A','O'];
  206.       writeln(mode);
  207.       repeat
  208.           write('Baud rate : 3(00), 1(200) ? ');
  209.           read(kbd,baudrate);
  210.         until baudrate in ['1','3'];
  211.       writeln(baudrate);
  212.       Setup(mode,baudrate);
  213.     end;
  214. {.cp19}
  215.   procedure terminal;
  216.     var s, t: byte;
  217.         c: char;
  218.     begin {$I-}  {no I/O checking here}
  219.       writeln('Use ctrl-E to exit terminal mode.');
  220.       repeat
  221.           s := port[base+5];   {get status}
  222.           if datardy
  223.             then begin
  224.                    t := ord(get_rcv_char);   t := t and $7F;
  225.                    if t<>$7F then write(chr(t));
  226.                  end;
  227.             if keypressed and ((s and $20) = $20)
  228.               then begin
  229.                      read(kbd,c);
  230.                      port[base] := ord(c);
  231.                    end;
  232.         until (c = ^E);
  233.     end; {$I+}
  234. {.cp5}
  235.   procedure sendtext(str: maxstr);
  236.     var i: integer;
  237.     begin
  238.       for i:=1 to length(str) do send(str[i]);
  239.     end;
  240. {.cp20}
  241.   function Dial(PhoneNumber: PhoneStr): char;
  242.     var c, kc: char;
  243.         t: integer;
  244.     begin
  245.       HangUpPhone;  write(cr,lf,'Dialing: ',PhoneNumber);
  246.       delay(250);   SetDTR;   delay(250);   sendtext(cr);   delay(1000);
  247.       sendtext('AT '+mode+'M1V0DT'+PhoneNumber+cr);   delay(2000);
  248.       c := receive;   c := chr(0);   repeat  c := get_rcv_char  until (c=cr);
  249.       write(', Waiting for carrier ...');
  250.       t := 60 * loopspersec;
  251.       repeat
  252.           t := t - 1;
  253.           if datardy then c := get_rcv_char;
  254.           if keypressed then read(kbd,kc);
  255.         until (c in ['0'..'5']) or (t=0) or (kc=^E);
  256.       if c='1'
  257.         then writeln(' connected.')
  258.         else if (t=0) or (kc=^E) then c := '9';
  259.       Dial := c
  260.     end;
  261. {.cp15}
  262.   procedure SignOn;
  263.     var i: integer;
  264.         c: char;
  265.     begin
  266.       write('Signing on ... ');
  267.       delay(2000);
  268.       for i:=1 to 7
  269.         do begin
  270.              send('8');
  271.              delay(333);
  272.            end;
  273.       sendtext('('+cr);
  274.       delay(2500);   sendtext(SignOnLine+cr);
  275.       writeln('all set !');
  276.     end;
  277. {.pa}
  278.   procedure SendFile;
  279.     var j, sectornum, counter, checksum : integer;
  280.         filename : string[20];
  281.         c: char;
  282.  
  283.     procedure SendIt;
  284.       begin
  285.         sectornum := 1;
  286.         repeat
  287.             counter := 0;
  288.             blockread(WorkFile,sector,1);
  289.             repeat
  290.                 write(cr,'Sending sector ', sectornum);
  291.                 send(SOH);   send(chr(sectornum));   send(chr(-sectornum-1));
  292.                 checksum := 0;
  293.                 for j:=0 to lastbyte
  294.                   do begin
  295.                        send(chr(sector[j]));
  296.                        checksum := (checksum + sector[j]) mod 256
  297.                      end;
  298.                 send(chr(checksum));
  299.                 purgeline;
  300.                 counter := counter + 1;
  301.               until (readline(10) = ord(ack)) or (counter = retrymax);
  302.             sectornum := sectornum + 1
  303.           until (eof(WorkFile)) or (counter = retrymax);
  304.         if counter = retrymax
  305.           then writeln(cr,lf,'No ACK on sector')
  306.           else begin
  307.                  counter := 0;
  308.                  repeat
  309.                      send(EOT);
  310.                      counter := counter + 1
  311.                    until (readline(10)=ord(ack)) or (counter=retrymax);
  312.                  if counter = retrymax
  313.                    then writeln(cr,lf,'No ACK on EOT')
  314.                    else writeln(cr,lf,'Transfer complete');
  315.                end;
  316.       end;
  317.  
  318.   begin
  319.       write('Filename.Ext ? ');   readln(filename);
  320.       if length(filename)>0
  321.         then begin
  322.                assign(WorkFile,filename);
  323.                reset(WorkFile);
  324.                SendIt;
  325.                close(WorkFile)
  326.              end;
  327.   end;
  328. {.pa}
  329. procedure readfile;
  330.   var j, firstchar, sectornum,sectorcurrent, sectorcomp, errors,
  331.       checksum : integer;
  332.       errorflag : boolean;
  333.       filename : string[20];
  334.  
  335.   procedure ReceiveIt;
  336.     begin
  337.       sectornum := 0;   errors := 0;
  338.       send(nak);   send(nak);  { send ready characters }
  339.       repeat
  340.           errorflag := false;
  341.           repeat
  342.               firstchar := readline(20)
  343.             until firstchar in [ord(SOH),ord(EOT),timeout];
  344.           if firstchar = timeout then writeln(cr,lf,'Error - No starting SOH');
  345.           if firstchar = ord(SOH)
  346.             then begin
  347.                    sectorcurrent := readline(1);      {real sector number}
  348.                    sectorcomp := readline(1);         {+ inverse of above}
  349.                    if (sectorcurrent+sectorcomp)=255  {<-- becomes this #}
  350.                      then begin
  351.                             if (sectorcurrent=sectornum+1)
  352.                               then begin
  353.                                      checksum := 0;
  354.                                      for j := 0 to lastbyte
  355.                                        do begin
  356.                                             sector[j] := readline(1);
  357.                                             checksum := (checksum+sector[j]) and $00FF
  358.                                           end;
  359.                                      if checksum=readline(1)
  360.                                        then begin
  361.                                               blockwrite(WorkFile,sector,1);
  362.                                               errors := 0;
  363.                                               sectornum := sectorcurrent;
  364.                                               write(cr,'Received sector ',sectorcurrent);
  365.                                               send(ack)
  366.                                             end
  367.                                        else begin
  368.                                               writeln(cr,lf,'Checksum error');
  369.                                               errorflag := true
  370.                                             end
  371.                                    end
  372.                               else if (sectorcurrent=sectornum)
  373.                                      then begin
  374.                                             repeat until readline(1)=timeout;
  375.                                             writeln(cr,lf,'Received duplicate sector ', sectorcurrent);
  376.                                             send(ack)
  377.                                           end
  378.                                      else begin
  379.                                             writeln(cr,lf,'Synchronization error');
  380.                                             errorflag := true
  381.                                           end
  382.                           end
  383.                      else begin
  384.                             writeln(cr,lf,'Sector number error');
  385.                             errorflag := true
  386.                           end
  387.                  end;
  388.           if errorflag then begin
  389.                               errors := errors+1;
  390.                               repeat until readline(1)=timeout;
  391.                               send(nak)
  392.                             end;
  393.         until (firstchar in [ord(EOT),timeout]) or (errors = errormax);
  394.       if (firstchar=ord(EOT)) and (errors<errormax)
  395.         then begin
  396.                send(ack);
  397.                writeln(cr,lf,'Transfer complete')
  398.              end
  399.         else writeln(cr,lf,'Aborting');
  400.     end;
  401.  
  402.   begin
  403.     write('Filename.Ext ? ');   readln(filename);
  404.     if length(filename)>0
  405.       then begin
  406.              assign(WorkFile,filename);
  407.              rewrite(WorkFile);
  408.              ReceiveIt;
  409.              close(WorkFile);
  410.            end;
  411.   end;
  412. {.cp17}
  413.   function ReadPhoneList: integer;
  414.     var index: integer;
  415.     begin
  416.       assign(PhoneFile,'MODEM.PHN');
  417.       index := 0;
  418.       {$I-}  reset(PhoneFile);  {$I+}
  419.       if IOresult=0
  420.         then begin
  421.                while (not eof(PhoneFile)) and (index<26)
  422.                  do begin
  423.                       index := index + 1;
  424.                       readln(PhoneFile,PhoneList[index]);
  425.                     end;
  426.                close(PhoneFile);
  427.              end;
  428.       ReadPhoneList := index;
  429.     end;
  430. {.cp41}
  431.   procedure Call;
  432.     var rc: char;
  433.         selection, i, j, k: integer;
  434.         PhoneNo: PhoneStr;
  435.     begin
  436.       if N_Phones>0
  437.         then begin
  438.                clrscr;   writeln;
  439.                for i:=1 to N_Phones
  440.                  do begin
  441.                       if (i mod 2)=0
  442.                         then write('      ')
  443.                         else writeln;
  444.                       write(chr(i+64),' - ',PhoneList[i]);
  445.                     end;
  446.                writeln;   writeln;   write('Enter selection letter: ');
  447.                repeat
  448.                    repeat until keypressed;
  449.                    read(kbd,rc);   rc := upcase(rc);
  450.                    selection := ord(rc) - ord('@');
  451.                  until (selection in [1..N_Phones]);
  452.                writeln(rc);
  453.                mode     := PhoneList[selection][31];
  454.                baudrate := PhoneList[selection][32];
  455.                Setup(mode,baudrate);
  456.                j := 30;   PhoneNo := '';
  457.                while PhoneList[selection][j]<>'.' do j:=j-1;
  458.                for k:=j+1 to 30 do PhoneNo := PhoneNo + PhoneList[selection][k];
  459.                rc := Dial(PhoneNo);
  460.              end
  461.         else rc := Dial(FredsPhone);
  462.       if rc='1'
  463.         then begin
  464.                if N_Phones=0
  465.                  then SignOn
  466.                  else if selection=1 then Signon;
  467.                terminal;
  468.              end
  469.         else HangUpPhone;
  470.     end;
  471. {.cp22}
  472.   procedure GetOption;
  473.     begin
  474.       clrscr;
  475.       writeln('Modem, ',Version);
  476.       gotoxy(7,4);   writeln('Options:');
  477.       writeln;
  478.       writeln('  R - receive a file');
  479.       writeln('  S - send a file');
  480.       writeln('  T - terminal mode');
  481.       writeln;
  482.       writeln('  C - place a call');
  483.       writeln('  H - hang up the phone');
  484.       writeln('  O - option configuration');
  485.       writeln('  X - exit to system');
  486.       writeln;   write('which ? ');
  487.       repeat
  488.           read(kbd,option);
  489.           option := upcase(option);
  490.         until option IN ['O','C','R','S','T','H','X'];
  491.       writeln(option);
  492.     end;
  493. {.cp16}
  494. begin {Modem}
  495.   Set_RS232_Vector;
  496.   N_Phones := ReadPhoneList;
  497.   Setup('O','1');   { default of Originate/1200 baud }
  498.   repeat
  499.       GetOption;
  500.       case option of
  501.         'T': Terminal;
  502.         'R': ReadFile;
  503.         'S': SendFile;
  504.         'O': Initialize;
  505.         'C': Call;
  506.         'H': HangUpPhone;
  507.         'X': return := 'Y';
  508.       end;
  509.     until return='Y';
  510.   inline($E4/$21/$0C/$10/$E6/$21); {turn on IRQ mask bit - disabled}
  511. (*  INT4 := oldvec;  {restore the old RS232 vector} *)
  512. end.
  513.